Option Compare Database
Option Explicit
Dim unidad(0 To 9) As String
Dim decena(0 To 9) As String
Dim centena(0 To 10) As String
Dim deci(0 To 9) As String
Dim otros(0 To 15) As String

Private m_Sexo1 As String
Private m_Sexo2 As String
Private m_LenSexo1 As Long

Public Enum eSexo
    Femenino '= 0
    Masculino '= 1
End Enum

Public Function Numero2Letra(ByVal strNum As String, _
                            Optional ByVal Lo As Long = 0&, _
                            Optional ByVal NumDecimales As Long = 2&, _
                            Optional ByVal sMoneda As String = "", _
                            Optional ByVal sCentimos As String = "", _
                            Optional ByVal SexoMoneda As eSexo = Femenino, _
                            Optional ByVal SexoCentimos As eSexo = Masculino) As String
    Dim i As Long
    Dim iHayDecimal As Long             'Posición del signo decimal
    Dim sDecimal As String              'Signo decimal a usar
    Dim sDecimalNo As String            'Signo no decimal
    Dim sEntero As String
    Dim sFraccion As String
    Dim fFraccion As Single
    Dim sNumero As String
    Static SexoAntMoneda As eSexo
    Static SexoAntCentimos As eSexo
On Error GoTo HandleErr
    '
    If SexoMoneda = Femenino Then
        m_Sexo1 = "a"
        m_Sexo2 = "as"
    Else
        m_Sexo1 = ""
        m_Sexo2 = "os"
    End If
    If SexoMoneda <> SexoAntMoneda Then
        unidad(2) = ""
        SexoAntMoneda = SexoMoneda
    End If
    m_LenSexo1 = Len(m_Sexo1)
    
    sMoneda = Trim$(sMoneda)
    If Len(Trim$(sMoneda)) Then
        sMoneda = " " & sMoneda & " "
    Else
        sMoneda = " "
    End If
    
    sCentimos = Trim$(sCentimos)
    If Len(Trim$(sCentimos)) Then
        sCentimos = " " & sCentimos & " "
    Else
        sCentimos = " "
    End If
    If Lo Then
        sNumero = Space$(Lo)
    Else
        sNumero = ""
    End If
    
    strNum = ConvDecimal(strNum, sDecimal, sDecimalNo)
    
    iHayDecimal = InStr(strNum, sDecimal)
    If iHayDecimal Then
        sEntero = Left$(strNum, iHayDecimal - 1)
        sFraccion = Mid$(strNum, iHayDecimal + 1) & String$(NumDecimales, "0")
        sFraccion = Left$(sFraccion, NumDecimales + 1)
        fFraccion = Int((Val(sFraccion) / 100) * 10 + 0.5) * 10
        sFraccion = Left$(CStr(fFraccion), NumDecimales)
        Do While Right$(sFraccion, 1) = "0"
            sFraccion = Left$(sFraccion, Len(sFraccion) - 1)
        Loop
        fFraccion = Val(sFraccion)
        If fFraccion < 1 Then
            If Len(Trim$(sMoneda)) Then
                sMoneda = Pluralizar(sNumero, sMoneda)
            End If
            strNum = RTrim$(UnNumero(sEntero, m_Sexo1) & sMoneda)
            If Lo Then
                LSet sNumero = strNum
            Else
                sNumero = strNum
            End If
            Numero2Letra = sNumero
            Exit Function
        End If
        
        If Len(Trim$(sMoneda)) Then
            sMoneda = Pluralizar(sEntero, sMoneda)
        End If
        
        sEntero = UnNumero(sEntero, m_Sexo1)
        
        If Len(Trim$(sCentimos)) Then
            sCentimos = Pluralizar(sFraccion, sCentimos)
        End If
        If SexoCentimos = Masculino Then
            sFraccion = UnNumero(sFraccion, "")
        Else
            sFraccion = UnNumero(sFraccion, "a")
        End If
        '
        strNum = sEntero & sMoneda & "con " & sFraccion & sCentimos
        If Lo Then
            LSet sNumero = RTrim$(strNum)
        Else
            sNumero = RTrim$(strNum)
        End If
        Numero2Letra = sNumero
    Else
        If Len(Trim$(sMoneda)) Then
            sMoneda = Pluralizar(strNum, sMoneda)
        End If
        strNum = RTrim$(UnNumero(strNum, m_Sexo1) & sMoneda)
        If Lo Then
            LSet sNumero = strNum
        Else
            sNumero = strNum
        End If
        Numero2Letra = sNumero
    End If
ExitHere:
    Exit Function

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.Numero2Letra"    'ErrorHandler:$$N=Numero a Letras.Numero2Letra
    End Select
' End Error handling block.
End Function

Private Function UnNumero(ByVal strNum As String, ByVal Sexo1 As String) As String


    Dim dblNumero As Double
    
    Dim Negativo As Boolean
    Dim L As Integer
    Dim Una As Boolean
    Dim Millon As Boolean
    Dim Millones As Boolean
    Dim vez As Long
    Dim MaxVez As Long
    Dim k As Long
    Dim strQ As String
    Dim strB As String
    Dim strU As String
    Dim strD As String
    Dim strC As String
    Dim iA As Long
On Error GoTo HandleErr
    '
    Dim strN() As String
    Dim Sexo1Ant As String
    
    Const cAncho = 12
    Const cGrupos = cAncho \ 3
    
    Sexo1Ant = m_Sexo1
    m_Sexo1 = Sexo1
    
    m_LenSexo1 = Len(m_Sexo1)
    If unidad(1) <> "un" & Sexo1 Then
        InicializarArrays
    End If
    On Local Error GoTo 0
    
    If Len(strNum) = 0 Then
        strNum = "0"
    End If
    
    dblNumero = Abs(CDbl(strNum))
    Negativo = (dblNumero <> CDbl(strNum))
    strNum = LTrim$(RTrim$(Str$(dblNumero)))
    L = Len(strNum)
    
    If dblNumero < 1 Then
        UnNumero = "cero"
        Exit Function
    End If
    '
    Una = True
    Millon = False
    Millones = False
    If L < 4 Then Una = False
    If dblNumero > 999999 Then Millon = True
    If dblNumero > 1999999 Then Millones = True
    strB = ""
    strQ = strNum
    vez = 0
    
    ReDim strN(1 To cGrupos)
    strQ = Right$(String$(cAncho, "0") & strNum, cAncho)
    For k = Len(strQ) To 1 Step -3
        vez = vez + 1
        strN(vez) = Mid$(strQ, k - 2, 3)
    Next
    MaxVez = cGrupos
    For k = cGrupos To 1 Step -1
        If strN(k) = "000" Then
            MaxVez = MaxVez - 1
        Else
            Exit For
        End If
    Next
    For vez = 1 To MaxVez
        strU = ""
        strD = ""
        strC = ""
        strNum = strN(vez)
        L = Len(strNum)
        k = Val(Right$(strNum, 2))
        If Right$(strNum, 1) = "0" Then
            k = k \ 10
            strD = decena(k)
        ElseIf k > 10 And k < 16 Then
            k = Val(Mid$(strNum, L - 1, 2))
            strD = otros(k)
        Else
            strU = unidad(Val(Right$(strNum, 1)))
            If L - 1 > 0 Then
                k = Val(Mid$(strNum, L - 1, 1))
                strD = deci(k)
            End If
        End If
        '---Parche de Esteve
        If L - 2 > 0 Then
            k = Val(Mid$(strNum, L - 2, 1))
            'Con esto funcionará bien el 100100, por ejemplo...
            If k = 1 Then                       'Parche
                If Val(strNum) = 100 Then       'Parche
                    k = 10                      'Parche
                End If                          'Parche
            End If
            strC = centena(k) & " "
        End If
        '------
        If strU = "uno" And Left$(strB, 4) = " mil" Then strU = ""
        strB = strC & strD & strU & " " & strB
    
        If (vez = 1 Or vez = 3) Then
            If strN(vez + 1) <> "000" Then strB = " mil " & strB
        End If
        If vez = 2 And Millon Then
            If Millones Then
                strB = " millones " & strB
            Else
                strB = "un millón " & strB
            End If
        End If
    Next
    strB = Trim$(strB)
    If Right$(strB, 3) = "uno" Then
        strB = Left$(strB, Len(strB) - 1) & m_Sexo1 '"a"
    End If
    Do                              'Quitar los espacios dobles que haya por medio
        iA = InStr(strB, "  ")
        If iA = 0 Then Exit Do
        strB = Left$(strB, iA - 1) & Mid$(strB, iA + 1)
    Loop
    '
    If Left$(strB, 5 + m_LenSexo1) = "un" & m_Sexo1 & " un" Then
        strB = Mid$(strB, 4 + m_LenSexo1)
    End If
    '---Nueva comparación                                     (01:16 25/Ene/99)
    If Left$(strB, 5) = "un un" Then
        strB = Mid$(strB, 4)
    End If
    '
    If Left$(strB, 7 + m_LenSexo1) = "un" & m_Sexo1 & " mil " Then
        strB = Mid$(strB, 4 + m_LenSexo1)
    End If
    '
    If Left$(strB, 7) = "un mil " Then
        strB = Mid$(strB, 4)
    End If
    '
    If Right$(strB, 15 + m_LenSexo1) <> "millones mil un" & m_Sexo1 Then
        iA = InStr(strB, "millones mil un" & m_Sexo1)
        If iA Then strB = Left$(strB, iA + 8) & Mid$(strB, iA + 13)
    End If
    '---Nueva comparación                                   (15:13 25/Ene/99)
    If Right$(strB, 15) <> "millones mil un" Then
        iA = InStr(strB, "millones mil un")
        If iA Then strB = Left$(strB, iA + 8) + Mid$(strB, iA + 13)
    End If
    '
    If Millones Then
        If m_Sexo1 = "a" Then
            If (strB Like "*as * millones*") Then
                k = InStr(strB, "as ")
                If k Then
                    Mid$(strB, k) = "os "
                End If
            End If
            If (strB Like "*as millones*") Then
                k = InStr(strB, "as millones")
                If k Then
                    Mid$(strB, k) = "os millones"
                End If
            End If
        End If
    End If
    '
    If Right$(strB, 6) = "ciento" Then
        strB = Left$(strB, Len(strB) - 2)
    End If
    If Negativo Then strB = "menos " & strB
    
    UnNumero = Trim$(strB)
    
    'Restablecer el valor anterior
    m_Sexo1 = Sexo1Ant
    m_LenSexo1 = Len(m_Sexo1)
ExitHere:
    Exit Function

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.UnNumero"    'ErrorHandler:$$N=Numero a Letras.UnNumero
    End Select
' End Error handling block.
End Function

Private Sub InicializarArrays()
On Error GoTo HandleErr
    unidad(1) = "un" & m_Sexo1
    unidad(2) = "dos"
    unidad(3) = "tres"
    unidad(4) = "cuatro"
    unidad(5) = "cinco"
    unidad(6) = "seis"
    unidad(7) = "siete"
    unidad(8) = "ocho"
    unidad(9) = "nueve"
    decena(1) = "diez"
    decena(2) = "veinte"
    decena(3) = "treinta"
    decena(4) = "cuarenta"
    decena(5) = "cincuenta"
    decena(6) = "sesenta"
    decena(7) = "setenta"
    decena(8) = "ochenta"
    decena(9) = "noventa"
    centena(1) = "ciento"
    centena(2) = "doscient" & m_Sexo2
    centena(3) = "trescient" & m_Sexo2
    centena(4) = "cuatrocient" & m_Sexo2
    centena(5) = "quinient" & m_Sexo2
    centena(6) = "seiscient" & m_Sexo2
    centena(7) = "setecient" & m_Sexo2
    centena(8) = "ochocient" & m_Sexo2
    centena(9) = "novecient" & m_Sexo2
    centena(10) = "cien"                'Parche
    deci(1) = "dieci"
    deci(2) = "veinti"
    deci(3) = "treinta y "
    deci(4) = "cuarenta y "
    deci(5) = "cincuenta y "
    deci(6) = "sesenta y "
    deci(7) = "setenta y "
    deci(8) = "ochenta y "
    deci(9) = "noventa y "
    otros(1) = "1"
    otros(2) = "2"
    otros(3) = "3"
    otros(4) = "4"
    otros(5) = "5"
    otros(6) = "6"
    otros(7) = "7"
    otros(8) = "8"
    otros(9) = "9"
    otros(10) = "10"
    otros(11) = "once"
    otros(12) = "doce"
    otros(13) = "trece"
    otros(14) = "catorce"
    otros(15) = "quince"
ExitHere:
    Exit Sub

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.InicializarArrays"   'ErrorHandler:$$N=Numero a Letras.InicializarArrays
    End Select
' End Error handling block.
End Sub

Private Sub Class_Initialize()
On Error GoTo HandleErr
    m_Sexo1 = "a"
    m_Sexo2 = "as"
ExitHere:
    Exit Sub

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.Class_Initialize"    'ErrorHandler:$$N=Numero a Letras.Class_Initialize
    End Select
' End Error handling block.
End Sub

Private Function Pluralizar(ByVal sNumero As String, ByVal sMoneda As String) As String
    Dim dblTotal As Double
    
On Error GoTo HandleErr
    If Len(Trim$(sMoneda)) Then
        dblTotal = Val(sNumero)
        If dblTotal <> 1# Then
            sMoneda = Trim$(sMoneda)
            If InStr("aeiou", Right$(sMoneda, 1)) Then
                sMoneda = " " & sMoneda & "s "
            Else
                sMoneda = " " & sMoneda & "es "
            End If
        End If
    End If
    Pluralizar = sMoneda
ExitHere:
    Exit Function

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.Pluralizar"  'ErrorHandler:$$N=Numero a Letras.Pluralizar
    End Select
' End Error handling block.
End Function

Public Function ConvDecimal(ByVal strNum As String, _
                            Optional ByRef sDecimal As String = ",", _
                            Optional ByRef sDecimalNo As String = ".") As String
    Dim sNumero As String
    Dim i As Long
    Dim j As Long
On Error GoTo HandleErr
    sNumero = Format$(25.5, "#.#")
    If InStr(sNumero, ".") Then
        sDecimal = "."
        sDecimalNo = ","
    Else
        sDecimal = ","
        sDecimalNo = "."
    End If
    
    strNum = Trim$(strNum)
    If Left$(strNum, 1) = sDecimalNo Then
        Mid$(strNum, 1, 1) = sDecimal
    End If
    j = 0
    i = 1
    Do
        i = InStr(i, strNum, sDecimalNo)
        If i Then
            j = j + 1
            i = i + 1
        End If
    Loop While i
    
    If j = 1 Then
        i = InStr(strNum, sDecimalNo)
        If i Then
            If InStr(strNum, sDecimal) Then
                Mid$(strNum, i, 1) = " "
            Else
                Mid$(strNum, i, 1) = sDecimal
            End If
        End If
    Else
        i = 1
        Do
            i = InStr(i, strNum, sDecimalNo)
            If i Then
                j = j - 1
                If j = 0 Then
                    Mid$(strNum, i, 1) = sDecimal
                Else
                    Mid$(strNum, i, 1) = " "
                End If
                i = i + 1
            End If
        Loop While i
    End If
    j = 0
    Do
        i = InStr(strNum, " ")
        If i = 0 Then Exit Do
        strNum = Left$(strNum, i - 1) & Mid$(strNum, i + 1)
    Loop
    ConvDecimal = strNum
ExitHere:
    Exit Function

' Error handling block added by Error Handler Add-In. DO NOT EDIT this block of code.

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Se ha producido el Error " & Err.Number & ": " & Err.Description, vbCritical, "Numero a Letras.ConvDecimal" 'ErrorHandler:$$N=Numero a Letras.ConvDecimal
    End Select
' End Error handling block.
End Function